home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 4 / Eagles_Nest_Mac_Collection_Disc_4.TOAST / Database Management / FoxPro25#1 / FoxPro 2.5 Disk - 1 Setup.image / Genxtab.prg / Genxtab.bin
Text File  |  1993-12-04  |  35KB  |  1,125 lines
  1. *:*********************************************************************
  2. *:
  3. *: Procedure file: C:\FOXPRO2\GENXTAB\GENXTAB.PRG
  4. *:
  5. *:         System: GENXTAB
  6. *:         Author: Microsoft Corp.
  7. *:      Copyright (c) 1993, Microsoft Corp.
  8. *:  Last modified: 1/4/93     10:17
  9. *:
  10. *:  Procs & Fncts: APPERROR
  11. *:               : ESC_PROC
  12. *:               : JUSTFNAME()
  13. *:               : JUSTSTEM()
  14. *:               : BAILOUT
  15. *:               : DEFAULTEXT()
  16. *:               : ALERT
  17. *:               : ACTTHERM
  18. *:               : UPDTHERM
  19. *:               : MAPNAME()
  20. *:               : DEACTTHERMO
  21. *:               : FORCEEXT
  22. *:               : JUSTPATH
  23. *:               : ADDBS
  24. *:               : MAKESTRG
  25. *:
  26. *:          Calls: APPERROR       (procedure in GENXTAB.PRG)
  27. *:               : ESC_PROC       (procedure in GENXTAB.PRG)
  28. *:               : JUSTFNAME()    (function  in GENXTAB.PRG)
  29. *:               : JUSTSTEM()     (function  in GENXTAB.PRG)
  30. *:               : BAILOUT        (procedure in GENXTAB.PRG)
  31. *:               : DEFAULTEXT()   (function  in GENXTAB.PRG)
  32. *:               : ALERT          (procedure in GENXTAB.PRG)
  33. *:               : ACTTHERM       (procedure in GENXTAB.PRG)
  34. *:               : UPDTHERM       (procedure in GENXTAB.PRG)
  35. *:               : MAPNAME()      (function  in GENXTAB.PRG)
  36. *:               : DEACTTHERMO    (procedure in GENXTAB.PRG)
  37. *:
  38. *:           Uses: XTABTEMP.DBF   
  39. *:
  40. *:*********************************************************************
  41. ***********************************************************************
  42. *
  43. * Notes: This program is intended to be called by RQBE or a program
  44. *        generated by RQBE.  On entry, a table should be open in the
  45. *        current work area, and it should contain at most one record
  46. *        for each cell in a cross-tabulation.  This table *must* be in
  47. *        row order, or you will receive an "unexpected end of file"
  48. *        error when you run GENXTAB.
  49. *
  50. *        The rowfld field in each record becomes the y-axis (rows) for
  51. *        a cross-tab and the colfld field becomes the x-axis (columns)
  52. *        The actual cross-tab results are saved to the database name
  53. *        specified by "outfname."
  54. *
  55. *        The basic strategy goes like this.  Produce an empty database
  56. *        with one field/column for each unique value of input field
  57. *        colfld, plus one additional field for input field rowfld values.
  58. *        This process determines the column headings in the database.
  59. *        Next fill in the rows, but only for the first field in the output
  60. *        database--the one that contains values for input field rowfld.
  61. *        At this point, we have column headings "across the top"
  62. *        and row identifiers "down the side."  Finally, look up
  63. *        the cell values for the row/column intersections and put
  64. *        them into the output database.
  65. *
  66. *
  67. * Calling example:
  68. *        DO genxtab WITH 'XTAB.DBF',.T.,.T.,.T.,1,2,5,.T.
  69. *
  70. *        This command causes GENXTAB to write the output database to
  71. *        'XTAB.DBF'.  However, XTAB.DBF will be deleted and the output
  72. *        stored to a cursor called XTAB.  The input database will be closed
  73. *        at the conclusion of the program.  The rows in XTAB.DBF will
  74. *        contain the unique values of field 1 in the database that is
  75. *        selected when GENXTAB is called, the columns will contain
  76. *        unique values of field 2 in the input database, and the
  77. *        cell values will come from field 5 in the input database.
  78. *        The thermometer will be shown.  A total field will be created.
  79. *
  80. ***********************************************************************
  81.  
  82. PARAMETERS outfname,   ;
  83.    cursonly,   ;
  84.    closeinput, ;
  85.    showtherm,  ;
  86.    rowfld,     ;
  87.    colfld,     ;
  88.    cellfld,    ;
  89.    xfoot
  90.  
  91. PRIVATE ALL
  92.  
  93. m.g_dlgface     = IIF(_MAC,"Geneva","MS Sans Serif")
  94. m.g_dlgsize     = IIF(_MAC,10,8.000)
  95. m.g_dlgstyle = IIF(_MAC,"","B")
  96.  
  97. EXTERNAL ARRAY coluniq
  98. EXTERNAL ARRAY colcnt
  99.  
  100. * -------------------------------------------------------------------------
  101. * Do opening housekeeping
  102. * -------------------------------------------------------------------------
  103. IF SET("TALK") = "ON"
  104.    SET TALK OFF
  105.    xtalk_stat = "ON"
  106. ELSE
  107.    xtalk_stat = "OFF"
  108. ENDIF
  109. xsafe_stat = SET("SAFETY")
  110. SET SAFETY OFF
  111. xesc_stat = SET("ESCAPE")
  112. SET ESCAPE ON
  113. #if "MAC" $ UPPER(VERSION(1))
  114.    IF _MAC
  115.       m.mmacdesk = SET("MACDESKTOP")
  116.        SET MACDESKTOP ON
  117.    ENDIF
  118. #endif
  119. in_esc = ON('ESCAPE')
  120. in_err = ON('ERROR')
  121.  
  122. ON ERROR DO apperror WITH PROGRAM(),MESSAGE(),MESSAGE(1),LINENO(),ERROR()
  123. ON ESCAPE DO esc_proc
  124.  
  125. * -------------------------------------------------------------------------
  126. * Set default values for parameters
  127. * -------------------------------------------------------------------------
  128. IF PARAMETERS() < 1
  129.    m.outfname = 'XTAB.DBF'
  130. ENDIF
  131. IF PARAMETERS() < 2
  132.    * Default to creating the same kind of output as we got as input.
  133.    * If the input "database" is a cursor, make the output a cursor.
  134.    * If the input "database" is an actual database, make the output a table.
  135.    cname = justfname(DBF())
  136.    DO CASE
  137.    CASE EMPTY(cname)   && create a table if nothing is currently selected
  138.       cursonly = .F.
  139.    CASE ISDIGIT(LEFT(cname,1))
  140.       cursonly = .T.
  141.    OTHERWISE
  142.       cursonly = .F.
  143.    ENDCASE
  144. ENDIF
  145. IF PARAMETERS() < 3
  146.    * Close the input database
  147.    closeinput = .T.
  148. ENDIF
  149. IF PARAMETERS() < 4
  150.    * show the thermometer
  151.    showtherm = .T.
  152. ENDIF
  153. IF PARAMETERS() < 5
  154.    * the field position in the input database for the crosstab rows
  155.    m.rowfld = 1
  156. ENDIF
  157. IF PARAMETERS() < 6
  158.    * the field position in the input database for the crosstab columns
  159.    m.colfld = 2
  160. ENDIF
  161. IF PARAMETERS() < 7
  162.    * the field position in the input database for the crosstab cells
  163.    m.cellfld = 3
  164. ENDIF
  165. IF PARAMETERS() < 8
  166.    * Create a total field?
  167.    m.xfoot = .F.
  168. ENDIF
  169.  
  170. * Define characters that are not allowed in field names
  171. m.badchars     = 'ÅÇÉÑÖÜáàâäãåéèêëíìîïñóòôö†°¢£§• /\,-=:;{}[]!@#$%^&*.<>()'+;
  172.    '+|Äõúùûü¶ß®©™´¨≠ÆØ∞±≤≥¥µ∂∑∏π∫ªºΩæø¿¡¬√ƒ≈Δ«»… ÀÃÕŒœ'+;
  173.    '–—“”‘’÷◊ÿŸ⁄€‹›fifl‡·‚„‰ÂÊÁËÈÍÎÏÌÓÔÒÚÛÙıˆ˜¯˘˙˚¸˝˛'+CHR(39)
  174. * Map European characters to these
  175. m.stdascii     = 'ueaaaaceeeiiAaEaAooouuyouaiounN'
  176.  
  177. IF !showtherm
  178.    m.recthresh = 100000000    && don't show the thermometer
  179. ELSE
  180.    m.recthresh = 1            && show it if more than this many input records
  181. ENDIF
  182. m.g_thermwidth = 0              && Thermometer width
  183.  
  184. m.outfname     = removequotes(m.outfname)
  185. m.outstem      = juststem(m.outfname)
  186.  
  187. * -------------------------------------------------------------------------
  188. * Construct the output database structure
  189. * -------------------------------------------------------------------------
  190.  
  191. m.dbfname = ALIAS()
  192.  
  193. m.dbfstem = Juststem(m.dbfname)
  194.  
  195. therm_on = (RECCOUNT() >= recthresh)
  196.  
  197. * Select one, if no database is open in the current workarea
  198. m.ok = .F.
  199. DO WHILE NOT ok
  200.    DO CASE
  201.    CASE EMPTY(m.dbfname)
  202.       m.dbfname = GETFILE('DBF','Please locate the input database')
  203.       m.dbfstem = juststem(m.dbfname)
  204.       IF EMPTY(m.dbfname)
  205.          * User canceled out of dialog, so quit the program
  206.          DO bailout WITH .T.
  207.       ENDIF
  208.    CASE FULLPATH(defaultext(m.dbfname,'DBF')) == ;
  209.          FULLPATH(defaultext(m.outfname,'DBF'))
  210.       SET CURSOR OFF
  211.       WAIT WINDOW "The input and output databases must be different."
  212.       SET CURSOR ON
  213.       m.dbfname = ''
  214.    OTHERWISE
  215.       IF USED(m.dbfstem)
  216.          SELECT (m.dbfstem)
  217.       ELSE
  218.          SELECT 0
  219.          USE (m.dbfname) ALIAS (m.dbfstem)
  220.       ENDIF
  221.       IF FCOUNT() < 3
  222.          DO alert WITH "Crosstab input databases require; at least three fields"
  223.          m.dbfname = ''
  224.       ELSE
  225.          ok = .T.
  226.       ENDIF
  227.    ENDCASE
  228. ENDDO
  229.  
  230. IF RECCOUNT() = 0
  231.    DO alert WITH "Cannot prepare crosstab on empty database"
  232.    DO bailout WITH .T.  
  233. ENDIF
  234.    
  235. * Gather information on the currently selected database fields
  236. DIMENSION inpfields[FCOUNT(),4]
  237. m.numflds = AFIELDS(inpfields)
  238.  
  239. * Map the physical input database field to logical field positions
  240. m.rowfldname    = inpfields[m.rowfld,1]
  241. m.colfldname    = inpfields[m.colfld,1]
  242. m.cellfldname   = inpfields[m.cellfld,1]
  243.  
  244. * None of these fields are allowed to be memo fields
  245. IF inpfields[1,2] $ 'MGP'
  246.    DO alert WITH "The crosstab row field in the input; database cannot be a memo, general or picture  field."
  247.    DO bailout WITH .T.
  248. ENDIF
  249. IF inpfields[2,2] $ 'MGP'
  250.    DO alert WITH "The crosstab column field in the input; database cannot be a memo, general or picture field."
  251.    DO bailout WITH .T.
  252. ENDIF
  253. IF inpfields[3,2] $ 'MGP'
  254.    DO alert WITH "The crosstab cell field in the input; database cannot be a memo, general or picture field."
  255.    DO bailout WITH .T.
  256. ENDIF
  257.  
  258. IF therm_on
  259.    DO acttherm WITH "Generating cross-tabulation ..."
  260.    DO updtherm WITH 5
  261. ENDIF
  262.  
  263. * Set the mouse off to avoid flicker on some systems
  264. SET MOUSE OFF
  265.  
  266. * Count the number of columns we need to create the cross tab.
  267. * This step could be combined with the following one so that there
  268. * would only be one SELECT operation performed.  It is coded in this
  269. * way to avoid running out of memory if there are an unexpectedly
  270. * large number of unique values of field 2 in the input database.
  271. SELECT COUNT(DISTINCT &colfldname) FROM (m.dbfname) INTO ARRAY colcnt
  272.  
  273. DO CASE
  274. CASE colcnt[1] > 254
  275.    DO alert WITH "Too many unique values of "+PROPER(m.colfldname);
  276.       + ".;  The maximum is 254."
  277.    DO bailout WITH .T.
  278. CASE colcnt[1] = 0
  279.    DO alert WITH "No columns found."
  280.    DO bailout WITH .T.
  281. ENDCASE
  282.  
  283. * Get the number of decimal places in numeric fields
  284. * and extract all the unique values of colfldname  
  285. IF inpfields[m.colfld,2] $ 'NF'   && numeric or floating field
  286.    m.cdec = inpfields[m.colfld,4]
  287.    * Handle numbers separately to preserve correct sort order
  288.    SELECT DISTINCT &colfldname ;
  289.       FROM (m.dbfname) INTO ARRAY coluniq
  290.    FOR i = 1 TO ALEN(coluniq)
  291.       coluniq[i] = mapname(coluniq[i],m.cdec)
  292.    ENDFOR
  293. ELSE        && non-numeric field
  294.    m.cdec = 0
  295.    * Create an array to hold the output database fields.
  296.    SELECT DISTINCT mapname(&colfldname,m.cdec) ;
  297.       FROM (m.dbfname) INTO ARRAY coluniq
  298. ENDIF
  299.  
  300. IF therm_on
  301.    DO updtherm WITH 15
  302. ENDIF
  303.  
  304. * The field type, length and decimals in the output array control the
  305. * cross-tab cells
  306. IF !m.xfoot
  307.    DIMENSION outarray[ALEN(coluniq)+1,4]
  308. ELSE
  309.    DIMENSION outarray[ALEN(coluniq)+2,4]
  310. ENDIF
  311.  
  312. * Field 1 in the output DBF holds the unique values of the row input field.
  313. * It is handled separately from the other fields, which take their names
  314. * from input database colfld and their parameters (e.g., length) from
  315. * input database cellfld.
  316.  
  317. outarray[1,1] = mapname(inpfields[1,1])
  318. outarray[1,2] = inpfields[1,2]
  319. outarray[1,3] = inpfields[1,3]
  320. outarray[1,4] = inpfields[1,4]
  321.  
  322. FOR i = 2 TO ALEN(coluniq) + 1
  323.    outarray[i,1] = mapname(coluniq[i-1],m.cdec)
  324.    outarray[i,2] = inpfields[3,2]                   && field type
  325.    outarray[i,3] = inpfields[3,3]                   && field length
  326.    outarray[i,4] = inpfields[3,4]                   && decimals
  327. ENDFOR
  328.  
  329. * Create a field for the cross-footing, if that option was selected
  330. IF m.xfoot
  331.    outarray[ALEN(coluniq)+2,1] = 'XTOTALS'
  332.    outarray[ALEN(coluniq)+2,2] = inpfields[3,2]
  333.    outarray[ALEN(coluniq)+2,3] = inpfields[3,3]
  334.    outarray[ALEN(coluniq)+2,4] = inpfields[3,4]
  335. ENDIF
  336.  
  337. * Make sure that the output file is not already in use somewhere
  338. IF USED(m.outstem)
  339.    SELECT (m.outstem)
  340.    USE
  341. ENDIF
  342.  
  343. IF !cursonly
  344.    CREATE TABLE (outfname) FROM ARRAY outarray
  345. ELSE
  346.    CREATE CURSOR (outfname) FROM ARRAY outarray
  347. ENDIF
  348.  
  349. IF therm_on
  350.    DO updtherm WITH 25
  351. ENDIF
  352.  
  353. * Get rid of the temporary arrays
  354. RELEASE outarray, coluniq, inpfields
  355.  
  356. * -------------------------------------------------------------------------
  357. * Add output database rows and replace the first field
  358. * -------------------------------------------------------------------------
  359.  
  360. * Select distinct rows into a table (instead of an array) so that 
  361. * there can be lots of rows.  If we select into an array, we may 
  362. * run out of RAM if there are many rows.
  363.  
  364. SELECT DISTINCT &rowfldname FROM (m.dbfname) INTO TABLE xtabtemp
  365.  
  366. IF therm_on
  367.    DO updtherm WITH 30
  368. ENDIF
  369.  
  370. SELECT (m.outstem)
  371. APPEND FIELD (FIELD(1)) FROM xtabtemp
  372.  
  373. IF therm_on
  374.    DO updtherm WITH 35
  375. ENDIF
  376. * -------------------------------------------------------------------------
  377. * Look up and replace the cell values
  378. * -------------------------------------------------------------------------
  379. *
  380. * This algorithm makes one pass through the input file, dropping its
  381. * values into the output file.  It exploits the fact that the output
  382. * file is known to be in row order.
  383. *
  384.  
  385. * Start at the top of the output file
  386. SELECT (m.outstem)
  387. GOTO TOP
  388. outf1name = FIELD(1)
  389.  
  390. * Start at the top of the input file
  391. SELECT (m.dbfstem)
  392. GOTO TOP
  393.  
  394. SCAN
  395.    m.f1 = EVAL(m.rowfldname)                  && get next row value from input
  396.    m.f2 = mapname(EVAL(m.colfldname),m.cdec)  && get corresponding column value
  397.    m.f3 = EVAL(m.cellfldname)                 && get cell value
  398.    
  399.    * Find the right row in the output file
  400.    SELECT (m.outstem)
  401.    DO WHILE !(EVAL(outf1name) == m.f1) AND !EOF()
  402.       SKIP
  403.    ENDDO
  404.    
  405.    IF !EOF()
  406.       IF TYPE(m.f2) $ "NF"
  407.          REPLACE (m.f2) WITH &f2 + m.f3 
  408.       ELSE
  409.          REPLACE (m.f2) WITH m.f3
  410.       ENDIF
  411.    ELSE
  412.       DO alert WITH "Unexpected end of output file.;" ;
  413.          + "The input file may be out of sequence."
  414.       DO bailout WITH .T.
  415.    ENDIF
  416.    
  417.    SELECT (m.dbfstem)
  418.    
  419.    * Map thermometer to remaining portion of display
  420.    IF therm_on
  421.       DO CASE
  422.       CASE RECCOUNT() > 1000
  423.          IF RECNO() % 100 = 0
  424.             DO updtherm WITH INT(RECNO() / RECCOUNT() * 65)+ 35
  425.          ENDIF
  426.       OTHERWISE
  427.          IF RECNO() % 10  = 0
  428.             DO updtherm WITH INT(RECNO() / RECCOUNT() * 65)+ 35
  429.          ENDIF
  430.       ENDCASE
  431.    ENDIF
  432. ENDSCAN
  433.  
  434. * Cross-foot the columns and put the results into the total field
  435. IF m.xfoot
  436.    SELECT (m.outstem)
  437.    m.totfldname = FIELD(FCOUNT())
  438.    SCAN
  439.       * Sum the relevant fields
  440.       m.gtotal = 0
  441.       FOR i = 2 TO FCOUNT() - 1
  442.          m.gtotal = m.gtotal + EVAL(FIELD(i))
  443.       ENDFOR
  444.       
  445.       REPLACE (m.totfldname) WITH m.gtotal
  446.    ENDSCAN
  447. ENDIF
  448.  
  449. IF therm_on
  450.    DO updtherm WITH 100
  451.    DO deactthermo
  452. ENDIF
  453.  
  454. IF USED("XTABTEMP")
  455.    SELECT xtabtemp
  456.    USE
  457. ENDIF
  458. IF FILE("xtabtemp.dbf")
  459.    DELETE FILE xtabtemp.dbf
  460. ENDIF
  461.  
  462. * Close the input database
  463. IF closeinput
  464.    SELECT (m.dbfstem)
  465.    USE
  466. ENDIF
  467.  
  468. * Leave the output database/cursor selected
  469. SELECT (m.outstem)
  470. GOTO TOP
  471.  
  472. * Do closing housekeeping
  473. DO bailout WITH .F.
  474.  
  475.  
  476. RETURN
  477.  
  478.  
  479. *!*********************************************************************
  480. *!
  481. *!       Function: MAPNAME()
  482. *!
  483. *!      Called by: GENXTAB.PRG                   
  484. *!
  485. *!          Calls: ALERT          (procedure in GENXTAB.PRG)
  486. *!               : BAILOUT        (procedure in GENXTAB.PRG)
  487. *!
  488. *!*********************************************************************
  489. FUNCTION mapname
  490. * Translate a field value of any type into a string containing a valid
  491. * field name.
  492.  
  493. PARAMETER in_name, in_dec
  494. IF PARAMETERS() = 1
  495.    in_dec = 0
  496. ENDIF
  497. DO CASE
  498. CASE TYPE("in_name") $ 'CM'
  499.    DO CASE
  500.    CASE EMPTY(m.in_name)
  501.       m.retval = 'C_BLANK'
  502.    OTHERWISE
  503.       m.retval = SUBSTR(CHRTRAN(m.in_name,m.badchars,m.stdascii),1,10)
  504.       IF !ISALPHA(LEFT(m.retval,1))
  505.          m.retval = 'C_'+LEFT(m.retval,8)
  506.       ENDIF
  507.    ENDCASE
  508. CASE TYPE("in_name") $ 'NF'
  509.    m.retval = 'N_'+ALLTRIM(CHRTRAN(STR(m.in_name,8,in_dec),'.',''))
  510. CASE TYPE("in_name") = 'D'
  511.    DO CASE
  512.    CASE EMPTY(m.in_name)
  513.       m.retval = 'D_BLANK'
  514.    OTHERWISE
  515.       m.retval = 'D_' + CHRTRAN(DTOS(m.in_name),m.badchars,m.stdascii)
  516.    ENDCASE
  517. CASE TYPE("in_name") = 'L'
  518.    IF m.in_name = .T.
  519.       m.retval = 'T'
  520.    ELSE
  521.       m.retval = 'F'
  522.    ENDIF
  523. CASE TYPE("in_name") = 'P'
  524.    DO alert WITH "Picture type fields are not allowed here."
  525.    DO bailout WITH .T.
  526. OTHERWISE
  527.    DO alert WITH "Unknown field type."
  528.    DO bailout WITH .T.
  529. ENDCASE
  530. m.retval = PADR(UPPER(ALLTRIM(m.retval)),10)
  531. RETURN m.retval
  532.  
  533. *!*********************************************************************
  534. *!
  535. *!       Function: JUSTSTEM()
  536. *!
  537. *!      Called by: GENXTAB.PRG                   
  538. *!
  539. *!*********************************************************************
  540. FUNCTION juststem
  541. * Return just the stem name from "filname"
  542. PARAMETERS filname
  543. PRIVATE ALL
  544. IF RAT('\',m.filname) > 0
  545.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  546. ENDIF
  547. IF RAT(':',m.filname) > 0
  548.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  549. ENDIF
  550. IF RAT('.',m.filname) > 0
  551.    m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1)
  552. ENDIF
  553. RETURN ALLTRIM(UPPER(m.filname))
  554.  
  555. *!*********************************************************************
  556. *!
  557. *!      Procedure: FORCEEXT
  558. *!
  559. *!          Calls: JUSTPATH       (procedure in GENXTAB.PRG)
  560. *!               : JUSTFNAME()    (function  in GENXTAB.PRG)
  561. *!               : ADDBS          (procedure in GENXTAB.PRG)
  562. *!
  563. *!*********************************************************************
  564. FUNCTION forceext
  565. * Force the extension of "filname" to be whatever ext is.
  566. PARAMETERS filname,ext
  567. PRIVATE ALL
  568. IF SUBSTR(m.ext,1,1) = "."
  569.    m.ext = SUBSTR(m.ext,2,3)
  570. ENDIF
  571.  
  572. m.pname = justpath(m.filname)
  573. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  574. IF RAT('.',m.filname) > 0
  575.    m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1) + '.' + m.ext
  576. ELSE
  577.    m.filname = m.filname + '.' + m.ext
  578. ENDIF
  579. RETURN addbs(m.pname) + m.filname
  580.  
  581. *!*********************************************************************
  582. *!
  583. *!       Function: DEFAULTEXT()
  584. *!
  585. *!      Called by: GENXTAB.PRG                   
  586. *!
  587. *!          Calls: JUSTPATH       (procedure in GENXTAB.PRG)
  588. *!               : JUSTFNAME()    (function  in GENXTAB.PRG)
  589. *!               : ADDBS          (procedure in GENXTAB.PRG)
  590. *!
  591. *!*********************************************************************
  592. FUNCTION defaultext
  593. * Add a default extension to "filname" if it doesn't have one already
  594. PARAMETERS filname,ext
  595. PRIVATE ALL
  596. IF SUBSTR(ext,1,1) = "."
  597.    m.ext = SUBSTR(m.ext,2,3)
  598. ENDIF
  599.  
  600. m.pname = justpath(m.filname)
  601. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  602. IF !EMPTY(m.filname) AND AT('.',m.filname) = 0
  603.    m.filname = m.filname + '.' + m.ext
  604.    RETURN addbs(m.pname) + m.filname
  605. ELSE
  606.    RETURN filname
  607. ENDIF
  608. *!*********************************************************************
  609. *!
  610. *!       Function: JUSTFNAME()
  611. *!
  612. *!      Called by: GENXTAB.PRG                   
  613. *!               : DEFAULTEXT()   (function  in GENXTAB.PRG)
  614. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  615. *!
  616. *!*********************************************************************
  617. FUNCTION justfname
  618. * Return just the filename (i.e., no path) from "filname"
  619. PARAMETERS filname
  620. PRIVATE ALL
  621. IF RAT('\',m.filname) > 0
  622.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  623. ENDIF
  624. IF RAT(':',m.filname) > 0
  625.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  626. ENDIF
  627. RETURN ALLTRIM(UPPER(m.filname))
  628.  
  629. *!*********************************************************************
  630. *!
  631. *!      Procedure: JUSTPATH
  632. *!
  633. *!      Called by: DEFAULTEXT()   (function  in GENXTAB.PRG)
  634. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  635. *!
  636. *!*********************************************************************
  637. FUNCTION justpath
  638. * Return just the path name from "filname"
  639. PARAMETERS m.filname
  640. PRIVATE ALL
  641. m.filname = ALLTRIM(UPPER(m.filname))
  642. m.pathsep = IIF(_MAC,":", "\")
  643. IF _MAC
  644.    m.found_it = .F.
  645.    m.maxchar = max(RAT("\", m.filname), RAT(":", m.filname))
  646.    IF m.maxchar > 0
  647.       m.filname = SUBSTR(m.filname,1,m.maxchar)
  648.       IF RIGHT(m.filname,1) $ ":\" AND LEN(m.filname) > 1 ;
  649.             AND !(SUBSTR(m.filname,LEN(m.filname)-1,1)  $ ":\")
  650.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  651.       ENDIF
  652.       RETURN m.filname
  653.    ENDIF
  654. ELSE
  655.    IF m.pathsep $ filname
  656.       m.filname = SUBSTR(m.filname,1,RAT(m.pathsep,m.filname))
  657.       IF RIGHT(m.filname,1) = m.pathsep AND LEN(m.filname) > 1 ;
  658.             AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> m.pathsep
  659.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  660.       ENDIF
  661.       RETURN m.filname
  662.    ENDIF      
  663. ENDIF
  664. RETURN ''
  665.  
  666. *!*********************************************************************
  667. *!
  668. *!      Procedure: ADDBS
  669. *!
  670. *!      Called by: DEFAULTEXT()   (function  in GENXTAB.PRG)
  671. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  672. *!
  673. *!*********************************************************************
  674. FUNCTION addbs
  675. * Add a backslash to a path name, if there isn't already one there
  676. PARAMETER pathname
  677. PRIVATE ALL
  678. m.pathname = ALLTRIM(UPPER(m.pathname))
  679. IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  680.    m.pathname = m.pathname + IIF(_MAC,":",'\')
  681. ENDIF
  682. RETURN m.pathname
  683.  
  684.  
  685. *!*********************************************************************
  686. *!
  687. *!      Procedure: APPERROR
  688. *!
  689. *!      Called by: GENXTAB.PRG                   
  690. *!
  691. *!          Calls: ALERT          (procedure in GENXTAB.PRG)
  692. *!               : BAILOUT        (procedure in GENXTAB.PRG)
  693. *!
  694. *!*********************************************************************
  695. PROCEDURE apperror
  696. * Simple ON ERROR routine
  697.  
  698. PARAMETERS e_program,e_message,e_source,e_lineno,e_error
  699. ON ERROR
  700. SET MOUSE ON
  701. m.e_source = ALLTRIM(m.e_source)
  702. DO alert WITH 'Line No.: '+ALLTRIM(STR(m.e_lineno,5))+';' ;
  703.    +'Program: '+m.e_program +';' ;
  704.    +'  Error: '+m.e_message +';' ;
  705.    +' Source: '+IIF(LEN(m.e_source)<50,;
  706.    m.e_source,SUBSTR(m.e_source,1,50)+'...')
  707. DO bailout WITH .T.
  708.  
  709. *!*********************************************************************
  710. *!
  711. *!      Procedure: ALERT
  712. *!
  713. *!      Called by: GENXTAB.PRG                   
  714. *!               : APPERROR       (procedure in GENXTAB.PRG)
  715. *!               : MAPNAME()      (function  in GENXTAB.PRG)
  716. *!
  717. *!*********************************************************************
  718. PROCEDURE alert
  719. * Display an error message, automatically sizing the message window
  720. *    as necessary.  Semicolons in "strg" mean "new line".
  721. PARAMETERS strg
  722. PRIVATE ALL
  723.  
  724. SET MOUSE ON
  725. in_talk = SET('TALK')
  726. SET TALK OFF
  727. in_cons = SET('CONSOLE')
  728.  
  729. m.numlines = OCCURS(';',m.strg) + 1
  730.  
  731. DIMENSION alert_arry[m.numlines]
  732. m.remain = m.strg
  733. m.maxlen = 0
  734. FOR i = 1 TO m.numlines
  735.    IF AT(';',m.remain) > 0
  736.       alert_arry[i] = SUBSTR(m.remain,1,AT(';',m.remain)-1)
  737.       alert_arry[i] = CHRTRAN(alert_arry[i],';','')
  738.       m.remain = SUBSTR(m.remain,AT(';',m.remain)+1)
  739.    ELSE
  740.       alert_arry[i] = m.remain
  741.       m.remain = ''
  742.    ENDIF
  743.    IF LEN(alert_arry[i]) > SCOLS() - 6
  744.       alert_arry[i] = SUBSTR(alert_arry[i],1,SCOLS()-6)
  745.    ENDIF
  746.    IF LEN(alert_arry[i]) > m.maxlen
  747.       m.maxlen = LEN(alert_arry[i])
  748.    ENDIF
  749. ENDFOR
  750.  
  751. m.top_row = INT( (SROWS() - 4 - m.numlines) / 2)
  752. m.bot_row = m.top_row + 3 + m.numlines
  753.  
  754. m.top_col = INT((SCOLS() - m.maxlen - 6) / 2)
  755. m.bot_col = m.top_col + m.maxlen + 6
  756.  
  757. IF _MAC
  758.     DEFINE WINDOW alert FROM m.top_row,m.top_col TO m.bot_row,m.bot_col;
  759.        DOUBLE COLOR SCHEME 7
  760. ELSE
  761.     DEFINE WINDOW alert FROM m.top_row,m.top_col TO m.bot_row,m.bot_col;
  762.        DOUBLE COLOR SCHEME 7
  763. ENDIF
  764. ACTIVATE WINDOW alert
  765.  
  766. FOR i = 1 TO m.numlines
  767.    @ i,3 SAY PADC(alert_arry[i],m.maxlen)
  768. ENDFOR
  769.  
  770. SET CONSOLE OFF
  771. keycode = INKEY(0,'HM')
  772. SET CONSOLE ON
  773.  
  774. RELEASE WINDOW alert
  775. IF m.in_talk = "ON"
  776.    SET TALK ON
  777. ENDIF
  778. IF m.in_cons = "OFF"
  779.    SET CONSOLE OFF
  780. ENDIF
  781.  
  782. RETURN
  783.  
  784. *!*********************************************************************
  785. *!
  786. *!      Procedure: MAKESTRG
  787. *!
  788. *!*********************************************************************
  789. FUNCTION makestrg
  790. PARAMETER in_val
  791. DO CASE
  792. CASE TYPE("in_val") = "C"
  793.    RETURN in_val
  794. CASE TYPE("in_val") $ "NF"
  795.    RETURN ALLTRIM(STR(in_val))
  796. CASE TYPE("in_val") = "D"
  797.    RETURN DTOC(in_val)
  798. CASE TYPE("in_val") = "L"
  799.    IF in_val
  800.       RETURN ".T."
  801.    ELSE
  802.       RETURN ".F."
  803.    ENDIF
  804. OTHERWISE
  805.    RETURN in_val
  806. ENDCASE
  807.  
  808. *!*********************************************************************
  809. *!
  810. *!      Procedure: ESC_PROC
  811. *!
  812. *!      Called by: GENXTAB.PRG                   
  813. *!
  814. *!          Calls: BAILOUT        (procedure in GENXTAB.PRG)
  815. *!
  816. *!*********************************************************************
  817. PROCEDURE esc_proc
  818. WAIT WINDOW "Cross tabulation terminated." TIMEOUT 1
  819. CLEAR TYPEAHEAD
  820. DO bailout
  821.  
  822. *!*********************************************************************
  823. *!
  824. *!      Procedure: BAILOUT
  825. *!
  826. *!      Called by: GENXTAB.PRG                   
  827. *!               : APPERROR       (procedure in GENXTAB.PRG)
  828. *!               : ESC_PROC       (procedure in GENXTAB.PRG)
  829. *!               : MAPNAME()      (function  in GENXTAB.PRG)
  830. *!
  831. *!           Uses: XTABTEMP.DBF   
  832. *!
  833. *!*********************************************************************
  834. PROCEDURE bailout
  835. PARAMETER docancl
  836. PRIVATE docancl
  837. DO CASE
  838. CASE PARAMETERS() = 0
  839.    m.docancl   = .T.
  840. ENDCASE
  841. IF WONTOP('THERMOMETE')
  842.    RELEASE WINDOW thermomete
  843. ENDIF
  844.  
  845. IF USED("XTABTEMP")
  846.    SELECT xtabtemp
  847.    USE
  848. ENDIF
  849. IF FILE("xtabtemp.dbf")
  850.    DELETE FILE xtabtemp.dbf
  851. ENDIF
  852.  
  853. IF m.xsafe_stat = "ON"
  854.    SET SAFETY ON
  855. ENDIF
  856. IF m.xesc_stat = "ON"
  857.    SET ESCAPE ON
  858. ELSE
  859.    SET ESCAPE OFF
  860. ENDIF
  861. IF m.xtalk_stat = "ON"
  862.    SET TALK ON
  863. ENDIF
  864. #if "MAC" $ UPPER(VERSION(1))
  865.    IF _MAC
  866.        SET MACDESKTOP &mmacdesk
  867.    ENDIF
  868. #endif
  869.  
  870. ON ERROR &in_err
  871. ON ESCAPE &in_esc
  872.  
  873. SET MOUSE ON
  874. IF m.docancl
  875.    m.outfname = ''
  876.    CANCEL
  877. ENDIF
  878.  
  879.  
  880. *
  881. * ACTTHERM(<text>) - Activate thermometer.
  882. *
  883. * Activates thermometer.  Update the thermometer with UPDTHERM().
  884. * Thermometer window is named "thermometer."  Be sure to RELEASE
  885. * this window when done with thermometer.  Creates the global
  886. * m.g_thermwidth.
  887. *
  888. *!*****************************************************************************
  889. *!
  890. *!      Procedure: ACTTHERM
  891. *!
  892. *!*****************************************************************************
  893. PROCEDURE acttherm
  894. PARAMETER m.prompt
  895. PRIVATE m.text
  896. m.text = ""
  897. IF _MAC OR _WINDOWS
  898.    IF TXTWIDTH(m.prompt, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle) > 43
  899.       DO WHILE TXTWIDTH(m.prompt+"...", m.g_dlgface, m.g_dlgsize, m.g_dlgstyle) > 43
  900.          m.prompt = LEFT(m.prompt, LEN(m.prompt)-1)
  901.       ENDDO
  902.       m.prompt = m.prompt + "..."
  903.    ENDIF
  904.    DO CASE
  905.    CASE _WINDOWS
  906.       DEFINE WINDOW thermomete ;
  907.          AT  INT((SROW() - (( 5.615 * ;
  908.          FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  909.          FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
  910.          INT((SCOL() - (( 63.833 * ;
  911.          FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  912.          FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
  913.          SIZE 5.615,63.833 ;
  914.          FONT m.g_dlgface, m.g_dlgsize ;
  915.          STYLE m.g_dlgstyle ;
  916.          NOFLOAT ;
  917.          NOCLOSE ;
  918.          NONE ;
  919.          COLOR RGB(0, 0, 0, 192, 192, 192)
  920.       MOVE WINDOW thermomete CENTER
  921.       ACTIVATE WINDOW thermomete NOSHOW
  922.  
  923.       @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
  924.       @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
  925.       @ 0.000,0.000 TO 0.000,63.833 ;
  926.          COLOR RGB(255, 255, 255, 255, 255, 255)
  927.       @ 0.000,0.000 TO 5.615,0.000 ;
  928.          COLOR RGB(255, 255, 255, 255, 255, 255)
  929.       @ 0.385,0.667 TO 5.231,0.667 ;
  930.          COLOR RGB(128, 128, 128, 128, 128, 128)
  931.       @ 0.308,0.667 TO 0.308,63.167 ;
  932.          COLOR RGB(128, 128, 128, 128, 128, 128)
  933.       @ 0.385,63.000 TO 5.308,63.000 ;
  934.          COLOR RGB(255, 255, 255, 255, 255, 255)
  935.       @ 5.231,0.667 TO 5.231,63.167 ;
  936.          COLOR RGB(255, 255, 255, 255, 255, 255)
  937.       @ 5.538,0.000 TO 5.538,63.833 ;
  938.          COLOR RGB(128, 128, 128, 128, 128, 128)
  939.       @ 0.000,63.667 TO 5.615,63.667 ;
  940.          COLOR RGB(128, 128, 128, 128, 128, 128)
  941.       @ 3.000,3.333 TO 4.231,3.333 ;
  942.          COLOR RGB(128, 128, 128, 128, 128, 128)
  943.       @ 3.000,60.333 TO 4.308,60.333 ;
  944.          COLOR RGB(255, 255, 255, 255, 255, 255)
  945.       @ 3.000,3.333 TO 3.000,60.333 ;
  946.          COLOR RGB(128, 128, 128, 128, 128, 128)
  947.       @ 4.231,3.333 TO 4.231,60.500 ;
  948.          COLOR RGB(255, 255, 255, 255, 255, 255)
  949.       m.g_thermwidth = 56.269
  950.    CASE _MAC
  951.       DEFINE WINDOW thermomete ;
  952.          AT  INT((SROW() - (( 5.62 * ;
  953.          FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  954.          FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
  955.          INT((SCOL() - (( 63.83 * ;
  956.          FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  957.          FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
  958.          SIZE 5.62,63.83 ;
  959.          FONT m.g_dlgface, m.g_dlgsize ;
  960.          STYLE m.g_dlgstyle ;
  961.          NOFLOAT ;
  962.          NOCLOSE ;
  963.             NONE ;
  964.          COLOR RGB(0, 0, 0, 192, 192, 192)
  965.       MOVE WINDOW thermomete CENTER
  966.       ACTIVATE WINDOW thermomete NOSHOW
  967.  
  968.       IF ISCOLOR()
  969.          @ 0.000,0.000 TO 5.62,63.83 PATTERN 1;
  970.              COLOR RGB(192, 192, 192, 192, 192, 192)
  971.           @ 0.000,0.000 TO 0.000,63.83 ;
  972.              COLOR RGB(255, 255, 255, 255, 255, 255)
  973.           @ 0.000,0.000 TO 5.62,0.000 ;
  974.              COLOR RGB(255, 255, 255, 255, 255, 255)
  975.           @ 0.385,0.67 TO 5.23,0.67 ;
  976.              COLOR RGB(128, 128, 128, 128, 128, 128)
  977.           @ 0.31,0.67 TO 0.31,63.17 ;
  978.              COLOR RGB(128, 128, 128, 128, 128, 128)
  979.           @ 0.385,63.000 TO 5.31,63.000 ;
  980.              COLOR RGB(255, 255, 255, 255, 255, 255)
  981.           @ 5.23,0.67 TO 5.23,63.17 ;
  982.              COLOR RGB(255, 255, 255, 255, 255, 255)
  983.           @ 5.54,0.000 TO 5.54,63.83 ;
  984.              COLOR RGB(128, 128, 128, 128, 128, 128)
  985.           @ 0.000,63.67 TO 5.62,63.67 ;
  986.              COLOR RGB(128, 128, 128, 128, 128, 128)
  987.           @ 3.000,3.33 TO 4.23,3.33 ;
  988.              COLOR RGB(128, 128, 128, 128, 128, 128)
  989.           @ 3.000,60.33 TO 4.31,60.33 ;
  990.              COLOR RGB(255, 255, 255, 255, 255, 255)
  991.           @ 3.000,3.33 TO 3.000,60.33 ;
  992.              COLOR RGB(128, 128, 128, 128, 128, 128)
  993.           @ 4.23,3.33 TO 4.23,60.33 ;
  994.              COLOR RGB(255, 255, 255, 255, 255, 255)
  995.       ELSE
  996.          @ 0.000, 0.000 TO 5.62, 63.830  PEN 2
  997.          @ 0.230, 0.500 TO 5.39, 63.333  PEN 1
  998.        ENDIF
  999.       @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
  1000.          COLOR RGB(0,0,0,192,192,192)
  1001.       @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
  1002.          COLOR RGB(0,0,0,192,192,192)
  1003.  
  1004.       m.g_thermwidth = 56.27
  1005.         IF !ISCOLOR()
  1006.            @ 3.000,3.33 TO 4.23,m.g_thermwidth + 3.33 
  1007.         ENDIF
  1008.    ENDCASE
  1009.    SHOW WINDOW thermomete TOP
  1010. ELSE
  1011.    m.prompt = SUBSTR(SYS(2014,m.g_outfile),1,48)+;
  1012.       IIF(LEN(m.g_outfile)>48,"...","")
  1013.  
  1014.    DEFINE WINDOW thermomete;
  1015.       FROM INT((SROW()-6)/2), INT((SCOL()-57)/2) ;
  1016.       TO INT((SROW()-6)/2) + 6, INT((SCOL()-57)/2) + 57;
  1017.       DOUBLE COLOR SCHEME 5
  1018.    ACTIVATE WINDOW thermomete NOSHOW
  1019.  
  1020.    m.g_thermwidth = 50
  1021.    @ 0,3 SAY m.text
  1022.    @ 1,3 SAY UPPER(m.prompt)
  1023.    @ 2,1 TO 4,m.g_thermwidth+4 &g_boxstrg
  1024.  
  1025.    SHOW WINDOW thermomete TOP
  1026. ENDIF
  1027. RETURN
  1028.  
  1029. *
  1030. * UPDTHERM(<percent>) - Update thermometer.
  1031. *
  1032. *!*****************************************************************************
  1033. *!
  1034. *!      Procedure: UPDTHERM
  1035. *!
  1036. *!      Called by: BUILD              (procedure in GENSCRN.PRG)
  1037. *!               : DISPATCHBUILD      (procedure in GENSCRN.PRG)
  1038. *!               : BUILDCTRL          (procedure in GENSCRN.PRG)
  1039. *!               : EXTRACTPROCS       (procedure in GENSCRN.PRG)
  1040. *!               : BUILDFMT           (procedure in GENSCRN.PRG)
  1041. *!
  1042. *!*****************************************************************************
  1043. PROCEDURE updtherm
  1044. PARAMETER m.percent
  1045. PRIVATE m.nblocks, m.percent
  1046.  
  1047. IF !WEXIST("thermomete")
  1048.    DO acttherm WITH "Generating cross-tabulation ..."
  1049. ENDIF
  1050. ACTIVATE WINDOW thermomete
  1051.  
  1052. m.nblocks = (m.percent/100) * (m.g_thermwidth)
  1053. DO CASE
  1054. CASE _WINDOWS
  1055.    @ 3.000,3.333 TO 4.231,m.nblocks + 3.333 ;
  1056.       PATTERN 1 COLOR RGB(128, 128, 128, 128, 128, 128)
  1057. CASE _MAC
  1058.    @ 3.000,3.33 TO 4.23,m.nblocks + 3.33 ;
  1059.       PATTERN 1 COLOR RGB(0, 0, 128, 0, 0, 128)
  1060. OTHERWISE
  1061.    @ 3,3 SAY REPLICATE("€",m.nblocks)
  1062. ENDCASE
  1063. RETURN
  1064.  
  1065. *
  1066. * DEACTTHERMO - Deactivate and Release thermometer window.
  1067. *
  1068. *!*****************************************************************************
  1069. *!
  1070. *!      Procedure: DEACTTHERMO
  1071. *!
  1072. *!*****************************************************************************
  1073. PROCEDURE deactthermo
  1074. IF WEXIST("thermomete")
  1075.    RELEASE WINDOW thermomete
  1076. ENDIF
  1077. RETURN
  1078.  
  1079.  
  1080. *!*****************************************************************************
  1081. *!
  1082. *!      Procedure: PARTIALFNAME
  1083. *!
  1084. *!*****************************************************************************
  1085. FUNCTION partialfname
  1086. PARAMETER m.filname, m.fillen
  1087. * Return a filname no longer than m.fillen characters.  Take some chars
  1088. * out of the middle if necessary.  No matter what m.fillen is, this function
  1089. * always returns at least the file stem and extension.
  1090. PRIVATE m.bname, m.elipse
  1091. m.elipse = "..." + c_pathsep
  1092. m.bname = justfname(m.filname)
  1093. DO CASE
  1094. CASE LEN(m.filname) <= m.fillen 
  1095.    RETURN filname
  1096. CASE LEN(m.bname) + LEN(m.elipse) >= m.fillen
  1097.    RETURN m.bname
  1098. OTHERWISE
  1099.    m.remain = MAX(m.fillen - LEN(m.bname) - LEN(m.elipse), 0)
  1100.    RETURN LEFT(justpath(m.filname),remain)+m.elipse+m.bname
  1101. ENDCASE
  1102.  
  1103. *!*****************************************************************************
  1104. *!
  1105. *!      Procedure: removequotes
  1106. *!
  1107. *!*****************************************************************************
  1108. FUNCTION removequotes
  1109. PARAMETER m.fname
  1110. PRIVATE m.leftchar, m.rightchar
  1111. m.fname = ALLTRIM(m.fname)
  1112. m.leftchar = LEFT(m.fname,1)
  1113. m.rightchar = RIGHT(m.fname, 1)
  1114.  
  1115. IF m.leftchar = '"' AND m.rightchar = '"'    ;
  1116.     OR m.leftchar = "'" AND m.rightchar = "'"  ;
  1117.     OR m.leftchar = '[' AND m.rightchar = ']'
  1118.         RETURN SUBSTR(m.fname, 2, LEN(m.fname) - 2)
  1119. ELSE
  1120.    RETURN m.fname        
  1121. ENDIF
  1122.  
  1123. *: EOF: GENXTAB.PRG
  1124.  
  1125.